home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC3.3 / M2HA.MOD < prev    next >
Encoding:
Text File  |  1992-05-29  |  85.4 KB  |  772 lines  |  [TEXT/MEDT]
  1. p = addrtyp) THEN RETURN END;
  2.     LoadD(x);
  3.     Put16(BNE + 12); (* if NOT NIL-pointer *)
  4.     GenHalt(5);
  5.   END CheckPointer;
  6.  
  7.   PROCEDURE LoadP(VAR x : Item);
  8.     (* load simple type or pointer to an address-register. *)
  9.     VAR y : Item; An : Register;
  10.   BEGIN
  11.     WITH x DO
  12.       IF (mode IN ItSet{RindMd,RidxMd}) & NOT(Islocked(R)) THEN
  13.         SetregMd(y, R, typ);
  14.         Move(x,y);
  15.         SetbusyReg(R);  (* do NOT release register R *)
  16.         IF mode = RidxMd THEN ReleaseReg(RX) END;
  17.         x := y;
  18.       ELSIF (mode < AregMd) OR (mode = DregMd) THEN
  19.         GetReg(An,Areg);
  20.         SetregMd(y, An, typ);
  21.         Move(x,y);
  22.         Release(x);
  23.         x := y;
  24.       ELSIF (mode # AregMd) THEN
  25.         err(230); Release(x);
  26.         SetregMd(x, A0+8, typ);
  27.       END;
  28.     END (*WITH*);
  29.   END LoadP;
  30.  
  31.   PROCEDURE LoadX(VAR x : Item; req : WidType);
  32.     (* load simple type x to a D-Register and    *)
  33.     (* sign extend it to the width given by req. *)
  34.  
  35.     VAR y : Item; Dn : Register; sz : WidType;
  36.         cload, signar : BOOLEAN; lv : LONGINT;
  37.  
  38.     PROCEDURE NewLoadX(VAR old, new : Item);
  39.     BEGIN
  40.       GetReg(Dn,Dreg);
  41.       SetregMd(new, Dn, old.typ);
  42.       IF NOT(signar) & (sz < req) & (sz < long) THEN
  43.         Put16(MOVEQ + Dn*LS9);
  44.       END;
  45.       Move(old,new);
  46.       Release(old);
  47.       IF signar & (sz < req) & (sz < long) THEN
  48.         IF sz = byte THEN Put16(EXTW + Dn) END;
  49.         IF req = long THEN Put16(EXTL + Dn) END;
  50.       END;
  51.       new.wid := req;
  52.     END NewLoadX;
  53.  
  54.   BEGIN (* LoadX *)
  55.     IF x.mode = cocMd THEN LoadCC(x) END;
  56.     Isz(x,sz);
  57.     cload := SimpleC(x); (* Real constants not included *)
  58.     signar := SignedT(x);
  59.     WITH x DO
  60.       IF cload THEN
  61.         (* constants always loaded to long width. *)
  62.         lv := LongVal(x);
  63.         GetReg(Dn,Dreg); SetregMd(y, Dn, typ);
  64.         IF (lv >= -128D) & (lv <= 127D) THEN
  65.           Put16(MOVEQ + Dn*LS9 + (WordVal(x) MOD 256));
  66.         ELSE (* not quick *)
  67.           Put16(MOVEL + Dn*LS9 + IMM);
  68.           Put32(lv);
  69.         END;
  70.         y.wid := req; (* long satisfies req anyway *)
  71.         x := y;
  72.       ELSIF (mode = DregMd) THEN
  73.         (* x is already in a D-Register. *)
  74.         IF wid < req THEN
  75.           IF req = word THEN
  76.             IF sz = byte THEN
  77.               IF signar THEN Put16(EXTW + R)
  78.               ELSE (* unsigned types *)
  79.                 Put16(ANDI + word*LS6 + R);
  80.                 Put16(377B);
  81.               END;
  82.             END;
  83.           ELSIF req = long THEN
  84.             IF signar THEN
  85.               IF sz < long THEN
  86.                 IF sz = byte THEN Put16(EXTW + R) END;
  87.                 Put16(EXTL + R);
  88.               END;
  89.             ELSE (* unsigned types *)
  90.               IF sz < long THEN
  91.                 Put16(ANDI + long*LS6 + R);
  92.                 IF sz = byte THEN Put32(255D) ELSE Put32(65535D) END;
  93.               END;
  94.             END;
  95.           END;
  96.         END (*wid < req*);
  97.         wid := req;
  98.       ELSIF (mode <= AregMd) THEN
  99.         (* Real constants fall into this variant. *)
  100.         NewLoadX(x,y);
  101.         x := y;
  102.       ELSE
  103.         err(230); Release(x);
  104.         SetregMd(x, D0, typ);
  105.       END;
  106.     END (*WITH*);
  107.   END LoadX;
  108.  
  109.   PROCEDURE MoveAdr(VAR x, y : Item);
  110.     (*   ADR(x)   --->>>  y      *)
  111.     VAR op, src, dst : INTEGER; o, s : StrPtr;
  112.   BEGIN
  113.     WITH x DO
  114.       o := typ;   (* save original type of x *)
  115.       s := y.typ; (* save original type of y *)
  116.       IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
  117.       OR ((mode = conMd) & (typ # stringtyp)) THEN
  118.         err(231); (* no effective address possible *)
  119.         Release(x); SetregMd(x, A0+8, undftyp);
  120.       END;
  121.       IF y.mode = stkMd THEN (* push address of x *)
  122.         op := 0;
  123.         IF (mode < conMd) & indir & (off = 0) THEN
  124.           indir := FALSE; op := MVEMSP;
  125.         END;
  126.         IF mode = procMd THEN GeaP(x,src) ELSE Gea(x,src) END;
  127.         IF mode = AregMd THEN
  128.           op := MVEMSP;   (* MOVE.L An,-(SP) *)
  129.         ELSIF op = 0 THEN
  130.           op := PEA;
  131.         END;
  132.         Put16(op + src);
  133.         Ext(x);
  134.       ELSE (* move address of x *)
  135.         IF (mode < conMd) & indir & (off = 0) THEN
  136.           indir := FALSE;
  137.         ELSE
  138.           LoadAdr(x);
  139.         END;
  140.         typ := addrtyp; y.typ := addrtyp;
  141.         Move(x,y);
  142.         IF y.mode = DregMd THEN y.wid := long END;
  143.       END;
  144.       typ := o;    (* restore original type of x *)
  145.       y.typ := s;  (* restore original type of y *)
  146.     END (*WITH*);
  147.     Release(x);  (* release associated registers *)
  148.   END MoveAdr;
  149.  
  150.   PROCEDURE MoveBlock(VAR x, y : Item; sz : INTEGER; isstring : BOOLEAN);
  151.     (*  Move a block of 'sz' bytes from x to y.  *)
  152.     (*                                           *)
  153.     (*  x.mode = stkMd :  block comes from stack *)
  154.     (*  y.mode = stkMd :  block goes onto stack  *)
  155.     (*                                           *)
  156.     (* Dogma : the implementation below presumes *)
  157.     (* -----   that all arrays and records are   *)
  158.     (*         allocated on a Word-boundary.     *)
  159.     (*                                           *)
  160.     VAR hsz, op, src, dst : INTEGER; z : Item; xmode : ItemMode;
  161.   BEGIN
  162.     IF (x.mode # stkMd) OR (y.mode # stkMd) THEN
  163.       xmode := x.mode; (* save original mode of source op. *)
  164.       IF y.mode = stkMd THEN
  165.         StackTop( - sz );
  166.         y.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
  167.       END;
  168.       IF x.mode = stkMd THEN
  169.         x.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
  170.       END;
  171.       LoadAdr(x); src := AINC + (x.R MOD 8);
  172.       LoadAdr(y); dst := AINC + (y.R MOD 8);
  173.       op := MOVEB; hsz := ABS(sz);
  174.       IF NOT isstring THEN
  175.         (* Note : always byte - move for Strings due to DBEQ! *)
  176.         IF    (hsz MOD 4) = 0 THEN op := MOVEL; hsz := hsz DIV 4
  177.         ELSIF (hsz MOD 2) = 0 THEN op := MOVEW; hsz := hsz DIV 2
  178.         END;
  179.       END;
  180.       op := op + Iea(dst)*LS6 + src;
  181.       IF    hsz = 1 THEN Put16(op)
  182.       ELSIF hsz = 2 THEN Put16(op); Put16(op)
  183.       ELSIF hsz = 3 THEN Put16(op); Put16(op); Put16(op)
  184.       ELSIF hsz > 0 THEN
  185.         SetconMd(z, hsz - 1, inttyp);
  186.         LoadD(z);
  187.         Put16(op);
  188.         IF isstring THEN Put16(DBEQ + z.R)
  189.         ELSE Put16(DBRA + z.R) END;
  190.         Put16(177774B);
  191.         ReleaseReg(z.R);
  192.       END;
  193.       IF xmode = stkMd THEN StackTop( sz ) END;
  194.     END;
  195.   END MoveBlock;
  196.  
  197.   PROCEDURE ConvertTyp(functyp : StrPtr; VAR x : Item);
  198.     VAR fs, xs : INTEGER; szf, szx : WidType; y : Item;
  199.   BEGIN
  200.     SetregMd(y, D0, functyp);  (* dummy for SimpleT *)
  201.     WITH x DO
  202.       fs := functyp^.size;
  203.       xs := typ^.size;
  204.       IF fs # xs THEN
  205.         IF SimpleT(x) & SimpleT(y) THEN
  206.           Isz(x,szx); Isz(y,szf);
  207.           IF mode = conMd THEN
  208.             SetconMd(x, LongVal(x), functyp);
  209.           ELSIF (mode <= DregMd) OR (mode = cocMd) THEN
  210.             IF szf <= szx THEN LoadD(x)
  211.             ELSE LoadX(x,szf) END;
  212.           ELSE err(81); Release(x);
  213.           END;
  214.         ELSE err(81); Release(x);
  215.         END;
  216.       END;
  217.       typ := functyp; (* type of x IS changed ! *)
  218.       IF (mode = DregMd) & SimpleT(y) THEN Isz(y,wid) END;
  219.     END (*WITH*);
  220.   END ConvertTyp;
  221.  
  222.   PROCEDURE CallSystem(sysp : INTEGER);
  223.     (* call System.#sysp where sysp = ordinal of procedure.  *)
  224.   BEGIN
  225.     ExternalCall(maxM - 1, sysp);
  226.   END CallSystem;
  227.  
  228.   PROCEDURE GenHalt(haltindex : INTEGER);
  229.   BEGIN
  230.     haltindex := haltindex MOD 256;
  231.     IF (haltindex # 0) & NOT(rngchk) THEN RETURN END;
  232.     Put16(MOVEQ + D0*LS9 + haltindex);
  233.     CallSystem(HALTX);
  234.   END GenHalt;
  235.  
  236.   PROCEDURE Int32Ari(inst : INTEGER; VAR x, y : Item);
  237.     (* Interface to the 32-Bit arithmetic in System.  *)
  238.     (*     x  (inst)  y   ---->>>   (D0.L,D1.L)       *)
  239.     VAR yy : Item;
  240.   BEGIN
  241.     SetregMd(yy, D1, dbltyp); y.typ := dbltyp;
  242.     Put16(MOVEL + x.R);      (* keep x.R reserved *)
  243.     Move(y,yy);
  244.     Release(y);              (* let go y's registers *)
  245.     CallSystem(inst);
  246.     (* result in register-pair (D0.L,D1.L). *)
  247.     (* x.wid := long; *)
  248.   END Int32Ari;
  249.  
  250.   PROCEDURE Op1(op : INTEGER; VAR x : Item);
  251.     (* generate instructions with 1 operand represented   *)
  252.     (* by an eff. address in bits [0..5] and its variable *)
  253.     (* sizeRegister;
  254.   BEGIN
  255.     (* width of set defines allowed bit-numbers *)
  256.     Isz(y,sz); min := 0;
  257.     max := LSH(8, sz) - 1;
  258.     IF SimpleC(x) & NOT SimpleC(y) THEN
  259.       (* static bit : *)
  260.       v := WordVal(x);
  261.       IF (v < min) OR (v > max) THEN
  262.         (* inhibit BTST :   *)
  263.         (* force Z-Bit = 1. *)
  264.         GetReg(Dn,Dreg);
  265.         Put16(MOVEQ + Dn*LS9);
  266.         ReleaseReg(Dn);
  267.       ELSE
  268.         LoadD(y); (* load bit pattern *)
  269.         op := BTST + LS11 - LS8 + y.R;
  270.         Put16(op);
  271.         Put16(v);
  272.       END;
  273.     ELSE
  274.       (* dynamic bit : *)
  275.       LoadD(y);                          (* load bit pattern    *)
  276.       LoadD(x);                          (* load bit number     *)
  277.       op := BTST + x.R*LS9 + y.R;
  278.       Put16(CMPI + x.wid*LS6 + x.R);     (* CMPI    #maxi,bitnr *)
  279.       IF x.wid = long THEN               (* inhibit BTST if     *)
  280.         Put32(max)                       (* bitnr out of width  *)
  281.       ELSE                               (* of the set          *)
  282.         Put16(max)
  283.       END;
  284.       Put16(BLS + 4);                    (* if bitnr in range   *)
  285.       Put16(MOVEQ + x.R*LS9);            (* force Z-Bit = 1     *)
  286.       Put16(BRA + 2);                    (* skip bitop-instr.   *)
  287.       Put16(op);                         (* dynamic bitop       *)
  288.     END;
  289.     Release(y);
  290.     (* result is in the condition code register! *)
  291.   END In2;
  292.  
  293.   PROCEDURE Neg1(VAR x : Item);
  294.   BEGIN
  295.     LoadD(x);
  296.     Op1(NEG,x);
  297.     OvflTrap(SignedT(x));
  298.   END Neg1;
  299.  
  300.   PROCEDURE Abs1(VAR x : Item);
  301.   BEGIN
  302.     LoadD(x);
  303.     Op1(TST,x);
  304.     Put16(BGE + 2);
  305.     Op1(NEG,x); (* gives exactly one 16-bit instruction *)
  306.     OvflTrap(SignedT(x));
  307.   END Abs1;
  308.  
  309.   PROCEDURE Cap1(VAR x : Item);
  310.   BEGIN
  311.     LoadD(x);
  312.     Put16(CMPI + byte*LS6 + x.R); Put16(97);
  313.     Put16(BCS + 10);
  314.     Put16(CMPI + byte*LS6 + x.R); Put16(122);
  315.     Put16(BHI + 4);
  316.     Put16(ANDI + byte*LS6 + x.R); Put16(95);
  317.   END Cap1;
  318.  
  319.   PROCEDURE Tst1(VAR x : Item);
  320.   BEGIN
  321.     IF x.mode IN ItSet{conMd,AregMd,cocMd} THEN LoadD(x) END;
  322.     Op1(TST,x);
  323.   END Tst1;
  324.  
  325.   PROCEDURE Com1(VAR x : Item);
  326.   BEGIN
  327.     LoadD(x);
  328.     Op1(COM,x);
  329.   END Com1;
  330.  
  331.   PROCEDURE Inc1(VAR x : Item);
  332.   BEGIN
  333.     Op1(INC1,x);
  334.     OvflTrap(SignedT(x));
  335.   END Inc1;
  336.  
  337.   PROCEDURE Dec1(VAR x : Item);
  338.   BEGIN
  339.     Op1(DEC1,x);
  340.     OvflTrap(SignedT(x));
  341.   END Dec1;
  342.  
  343.   PROCEDURE Add2(VAR x, y : Item);
  344.     VAR op : INTEGER; lv : LONGINT;
  345.   BEGIN op := ADD;
  346.     IF y.mode = conMd THEN lv := LongVal(y);
  347.       IF lv < 0D THEN SetconMd(y, -lv, y.typ); op := SUB END;
  348.     END;
  349.     ADD2(op,x,y);
  350.     IF x.mode # AregMd THEN OvflTrap(SignedT(x)) END;
  351.   END Add2;
  352.  
  353.   PROCEDURE Sub2(VAR x, y : Item);
  354.     VAR op : INTEGER; lv : LONGINT;
  355.   BEGIN op := SUB;
  356.     IF y.mode = conMd THEN lv := LongVal(y);
  357.       IF lv < 0D THEN SetconMd(y, -lv, y.typ); op := ADD END;
  358.     END;
  359.     ADD2(op,x,y);
  360.     IF x.mode # AregMd THEN OvflTrap(SignedT(x)) END;
  361.   END Sub2;
  362.  
  363.   PROCEDURE And2(VAR x, y : Item);
  364.   BEGIN
  365.     LOG2(ANDL,x,y);
  366.   END And2;
  367.  
  368.   PROCEDURE Or2(VAR x, y : Item);
  369.   BEGIN
  370.     LOG2(ORL,x,y);
  371.   END Or2;
  372.  
  373.   PROCEDURE Eor2(VAR x, y : Item);
  374.   BEGIN
  375.     LOG2(EORL,x,y);
  376.   END Eor2;
  377.  
  378.   PROCEDURE Div2(VAR x, y : Item);
  379.   BEGIN
  380.     IF (y.mode = conMd) & (LongVal(y) = 0D) THEN err(205)
  381.     ELSE DIV2(x,y, FALSE)
  382.     END;
  383.   END Div2;
  384.  
  385.   PROCEDURE Mod2(VAR x, y : Item);
  386.   BEGIN
  387.     IF (y.mode = conMd) & (LongVal(y) = 0D) THEN err(205)
  388.     ELSE DIV2(x,y, TRUE)
  389.     END;
  390.   END Mod2;
  391.  
  392.   PROCEDURE Mul2(VAR x, y : Item);
  393.   BEGIN
  394.     IF ((y.mode = conMd) & (LongVal(y) = 0D)) THEN
  395.       Release(x); SetconMd(x, 0D, x.typ)
  396.     ELSIF NOT((y.mode = conMd) & (LongVal(y) = 1D)) THEN
  397.       MUL2(x,y,TRUE)
  398.     END;
  399.   END Mul2;
  400.  
  401.   PROCEDURE Shi2(VAR x, y : Item; shiftop : ShiType);
  402.   BEGIN
  403.     SHI2( ShiCode[shiftop], x, y);
  404.   END Shi2;
  405.  
  406.   PROCEDURE Ash2(VAR x, y : Item; shiftop : ShiType);
  407.     (*                                         *)
  408.     (*     Arithmetic Shift                    *)
  409.     (*     Logical Shift        x by y.        *)
  410.     (*     Rotate Shift                        *)
  411.     (*                                         *)
  412.     (*  y is the shift count of type INTEGER   *)
  413.     (*  or INTEGER.                           *)
  414.     (*  if y >= 0 then shift LEFT.             *)
  415.     (*  if y <  0 then shift RIGHT.            *)
  416.     (*                                         *)
  417.     VAR op, ct, rm : INTEGER; sz : WidType;
  418.   BEGIN
  419.     Isz(x,sz);
  420.     op := ShiCode[shiftop] + sz*LS6 + (x.R MOD 8); (* initially LEFT shift *)
  421.     IF y.mode = conMd THEN
  422.       (* immediate shift count : bit 5 remains 0! *)
  423.       ct := WordVal(y);
  424.       IF ct < 0 THEN
  425.         op := op - LS8; (* RIGHT shift *)
  426.         (* Note : overflow-checks must be OFF for compiler! *)
  427.         ct := ABS(ct);
  428.       END;
  429.       ct := ct MOD 32; (* shift count modulo 32 *)
  430.       rm := ct MOD 8; ct := LSH(ct, -3);
  431.       IF rm # 0 THEN Put16(op + rm*LS9) END;
  432.       WHILE ct > 0 DO Put16(op); DEC(ct) END;
  433.     ELSE
  434.       (* variable shift count of type INTEGER : *)
  435.       (* INTEGER count treated the same way.    *)
  436.       (* Hardware takes shift count modulo 64   *)
  437.       LoadX(y,word);                     (* load shift count  *)
  438.       op := op + y.R*LS9 + LS5;          (* register shift    *)
  439.       Put16(TST + word*LS6 + y.R);       (* test shift count  *)
  440.       Put16(BPL + 6);                    (* if count >= 0     *)
  441.       Put16(NEG + word*LS6 + y.R);       (* abs. value count  *)
  442.       Put16(op - LS8);                   (* RIGHT shift       *)
  443.       Put16(BRA + 2);                    (* skip next instr.  *)
  444.       Put16(op);                         (* LEFT shift        *)
  445.     END;
  446.     x.wid := sz; (* resulting width of D-Register *)
  447.     Release(y);
  448.   END Ash2;
  449.  
  450.   PROCEDURE ConIndex(VAR x : Item; inc : INTEGER);
  451.     (* called for constant index and field-offset. *)
  452.     (*   if NOT indir :  adr-field is incremented  *)
  453.     (*   if indir     :  off-field is incremented. *)
  454.     VAR i : INTEGER;
  455.   BEGIN
  456.     WITH x DO
  457.       IF mode < conMd THEN
  458.         (* reference to indir, adr, off allowed. *)
  459.         IF NOT indir THEN i := adr ELSE i := off END;
  460.         IF (i >= 0) & (inc <= MaxInt - i)
  461.         OR (i <  0) & (inc >= MinInt - i) THEN
  462.           i := i + inc;
  463.           IF NOT indir THEN adr := i ELSE off := i END;
  464.         ELSE (* offset overflow *)
  465.           LoadAdr(x); mode := RindMd; (* transform 'AregMd' to 'RindMd' *)
  466.           adr := inc;
  467.         END;
  468.       ELSE (* all other modes *)
  469.         err(235);
  470.       END;
  471.     END (*WITH*);
  472.   END ConIndex;
  473.  
  474.   PROCEDURE Normalize(VAR x : Item; i : INTEGER);
  475.     (* normalize x with the low-bound i *)
  476.     VAR op : INTEGER; y : Item;
  477.   BEGIN
  478.     IF i # 0 THEN
  479.       (* Note : overflow-checks must be OFF for compiler! *)
  480.       IF i > 0 THEN op := SUB ELSE op := ADD; i := ABS(i) END;
  481.       SetconMd(y, i, x.typ);
  482.       ADD2(op,x,y);
  483.     END;
  484.   END Normalize;
  485.  
  486.   PROCEDURE CheckHigh(VAR x, high : Item);
  487.     (* check item associated with x to be in the   *)
  488.     (* range indicated by [ 0.. (high) ].          *)
  489.     (* Note : CHK treats operand and upper-bound   *)
  490.     (*        as signed 2's complement integers!   *)
  491.     VAR ea : INTEGER; sz, hsz : WidType;
  492.   BEGIN
  493.     IF NOT rngchk THEN RETURN END;
  494.     LoadD(x); (* assert x to be loaded into a D-register *)
  495.     Isz(high,hsz); Isz(x,sz);
  496.     IF sz = word THEN (* use CHK-instruction *)
  497.       IF hsz # word THEN LoadD(high) END;
  498.       Gea(high,ea);
  499.       Put16(CHK + x.R*LS9 + ea);
  500.       Ext(high);
  501.     ELSE (* use CMP-instruction *)
  502.       IF hsz # sz THEN LoadX(high,sz) END;
  503.       Gea(high,ea);
  504.       Put16(CMP + x.R*LS9 + sz*LS6 + ea);
  505.       Ext(high);
  506.       Put16(BLS + 4);
  507.       Put16(CHK + x.R*LS9 + IMM); (* trap always *)
  508.       Put16(-1);
  509.     END;
  510.     Release(high);
  511.   END CheckHigh;
  512.  
  513.   PROCEDURE CheckClimit(VAR x : Item; limit : LONGINT);
  514.     (* check item associated with x to be in the   *)
  515.     (* range indicated by [ 0 .. limit ].          *)
  516.     (* Note : Trap taken always if limit < 0.      *)
  517.     (*        CHK treats operand and upper-bound   *)
  518.     (*        as signed 2's complement integers!   *)
  519.     VAR sz : WidType;
  520.   BEGIN
  521.     IF NOT rngchk THEN RETURN END;
  522.     IF (limit < 0D) THEN err(286) END; (* invalid limit *)
  523.     Lut16(-2);
  524.     Put16(BEQ + 6);                        (* BEQ      +6        *)
  525.     Unlink(0,0);                           (* exactly 6 Bytes!   *)
  526.   END EnterModule;
  527.  
  528.   PROCEDURE InitModule(m : INTEGER);
  529.   BEGIN
  530.     ExternalCall(m, 0);
  531.   END InitModule;
  532.  
  533.   PROCEDURE LoadF(VAR x : Item);
  534.     (* Load x into a Floating-Point-Register.                        *)
  535.     (* The current implementation simulates Floating-Point-Registers *)
  536.     (* by means of one (single) D-Register or a (double) D-Register- *)
  537.     (* Pair.                                                         *)
  538.     VAR Dn : Register; ea : INTEGER;
  539.   BEGIN
  540.     WITH x DO
  541.       IF typ = realtyp THEN (* single real *) LoadD(x)
  542.       ELSE (* double real *)
  543.         (* transform all modes to 'fltMd' : *)
  544.         IF mode <= stkMd THEN
  545.           GetFReg(Dn);
  546.           Gea(x,ea);
  547.           IF mode = conMd THEN
  548.             (* Note : NO immeditate's for MOVEM! *)
  549.             Put16(MOVELIMM + Dn*1000B);
  550.             Put16(val.D0); Put16(val.D1);
  551.             Put16(MOVELIMM + (Dn+1)*1000B);
  552.             Put16(val.D2); Put16(val.D3);
  553.           ELSE
  554.             Put16(MOVEMLDD + ea);
  555.             Put16(LSH(3, Dn));
  556.             Ext(x);
  557.           END;
  558.           Release(x); (* NOW release old registers! *)
  559.           mode := fltMd; FR := Dn;
  560.         ELSIF mode # fltMd THEN
  561.           err(239); Release(x);
  562.           mode := fltMd; FR := D0;
  563.         END;
  564.       END;
  565.     END (*WITH*);
  566.   END LoadF;
  567.  
  568.   PROCEDURE FMove(VAR x, y : Item);
  569.     (* floating move  x  --->>  y           *)
  570.     (* perform floating type moves :        *)
  571.     (*        memory    to   memory         *)
  572.     (*        register  to   memory         *)
  573.     (*        memory    to   register       *)
  574.     (* The current implementation simulates Floating-Point-Registers *)
  575.     (* by means of one (single) D-Register or a (double) D-Register- *)
  576.     (* Pair.                                                         *)
  577.  
  578.     VAR Dn : Register; ea : INTEGER;
  579.   BEGIN
  580.     IF x.typ = realtyp THEN (* single real *) Move(x,y)
  581.     ELSIF (x.mode # stkMd) OR (y.mode # stkMd) THEN (* double real *)
  582.       IF (x.mode <= stkMd) THEN
  583.         (* Preload floating value to scratch D0/D1 : *)
  584.         (* Don't waste D-pool-Registers !            *)
  585.         WITH x DO
  586.           (* transform all modes to 'fltMd' : *)
  587.           IF mode = conMd THEN
  588.             (* Note : NO immeditate's for MOVEM! *)
  589.             Put16(MOVELIMM + D0*1000B);
  590.             Put16(val.D0); Put16(val.D1);
  591.             Put16(MOVELIMM + D1*1000B);
  592.             Put16(val.D2); Put16(val.D3);
  593.           ELSE
  594.             Gea(x,ea);
  595.             Put16(MOVEMLDD + ea);
  596.             Put16(3); (* register list for D0/D1 *)
  597.             Ext(x);
  598.             Release(x); (* NOW release old registers! *)
  599.           END;
  600.           mode := fltMd; FR := D0;
  601.         END (*WITH x*);
  602.       END;
  603.       IF (x.mode <= stkMd) & (y.mode = fltMd) THEN
  604.         (* memory to register : *)
  605.         Dn := y.FR;
  606.         Gea(x,ea);
  607.         Put16(MOVEMLDD + ea);
  608.         Put16(LSH(3, Dn));
  609.         Ext(x);
  610.       ELSIF (x.mode = fltMd) & (y.mode <= stkMd) THEN
  611.         (* register to memory : *)
  612.         Dn := x.FR;
  613.         IF y.mode = stkMd THEN
  614.           Put16(MOVEMDEC);
  615.           Put16(LSH(3, 14 - Dn));
  616.         ELSE
  617.           Gea(y,ea);
  618.           Put16(MOVEMSTD + ea);
  619.           Put16(LSH(3, Dn));
  620.           Ext(y);
  621.         END;
  622.       ELSIF (x.mode = fltMd) & (y.mode = fltMd) THEN
  623.         (* register to register : *)
  624.         Dn := y.FR;
  625.         IF x.FR # Dn THEN
  626.           Put16(MOVEL + Dn*1000B + x.FR);
  627.           Put16(MOVEL + (Dn+1)*1000B + (x.FR+1));
  628.         END;
  629.       ELSE (* illegal modes *) err(241)
  630.       END;
  631.     END (*double*);
  632.   END FMove;
  633.  
  634.   PROCEDURE FOp1(op : INTEGER; VAR x : Item);
  635.     (* Interface to the SANE interface in module System *)
  636.     (* for monadic Floating-Point-Operations.           *)
  637.     VAR regs : LONGINT; y : Item; rtyp : StrPtr;
  638.   BEGIN
  639.     WITH x DO
  640.       SetfltMd(y, D0, typ);         (* load into scratch D0/D1 *)
  641.       FMove(x,y);
  642.       Release(x);
  643.       x := y;
  644.       Release(x);                   (* so D0/D1 are NOT saved *)
  645.       SaveRegs(regs);               (* save busy registers *)
  646.       CASE op OF
  647.         (* define resulting type *)
  648.         FNEGs,  FABSs  : rtyp := realtyp;
  649.       | FNEGd,  FABSd  : rtyp := lrltyp;
  650.       | TRUNCs, TRUNCd : rtyp := dbltyp;
  651.       | FLOATs, FSHORT : rtyp := realtyp;
  652.       | FLOATd, FLONG  : rtyp := lrltyp;
  653.       END;
  654.       StackTop( - rtyp^.size );     (* space for function result *)
  655.       SetstkMd(y, typ);
  656.       FMove(x,y);                   (* push parameter onto stack *)
  657.       Release(x);                   (* now release the parameter *)
  658.       CallSystem(op);               (* call the function in System *)
  659.       SetstkMd(x, rtyp);            (* result on top of stack *)
  660.       IF regs # 0D THEN            (* saved regs above result *)
  661.         IF SimpleT(x) THEN LoadD(x)
  662.         ELSE LoadF(x) END;
  663.         RestoreRegs(regs);          (* restore busy registers *)
  664.       END;
  665.     END (*WITH*);
  666.   END FOp1;
  667.  
  668.   PROCEDURE FOp2(op : INTEGER; VAR x, y : Item);
  669.     (* Interface to the SANE interface in module System *)
  670.     (* for dyadic Floating-Point-Operations.            *)
  671.     VAR regs : LONGINT; z : Item; rtyp : StrPtr;
  672.         Regs : RECORD
  673.                  CASE :BOOLEAN OF
  674.                      TRUE : All : LONGINT
  675.                    | FALSE: X,F,D,A : CHAR
  676.                  END
  677.                END;
  678.   BEGIN
  679.     SetfltMd(z, D0, y.typ);       (* load y into scratch D0/D1 *)
  680.     FMove(y,z);                   (* y must be loaded first (stkMd) *)
  681.     Release(y);
  682.     y := z;
  683.     Release(y);                   (* so D0/D1 are NOT saved *)
  684.     LoadF(x);                     (* load x into scratch Dn/Dn+1 *)
  685.     Release(x);                   (* so Dn/Dn+1 are NOT saved *)
  686.     SaveRegs(regs);               (* save busy registers *)
  687.     CASE op OF
  688.       (* define resulting type *)
  689.       FADDs, FSUBs, FMULs, FDIVs, FREMs : rtyp := realtyp;
  690.     | FADDd, FSUBd, FMULd, FDIVd, FREMd : rtyp := lrltyp;
  691.     | FCMPs, FCMPd                      : rtyp := notyp;
  692.     END;
  693.     IF rtyp # notyp THEN
  694.       StackTop( - rtyp^.size );   (* space for function result *)
  695.     END;
  696.     SetstkMd(z, x.typ);
  697.     FMove(x,z);                   (* push x-parameter onto stack *)
  698.     Release(x);                   (* now release the x-parameter *)
  699.     SetstkMd(z, y.typ);
  700.     FMove(y,z);                   (* push y-parameter onto stack *)
  701.     Release(y);                   (* now release the y-parameter *)
  702.     CallSystem(op);               (* call the function in System *)
  703.     SetstkMd(x, rtyp);            (* result on top of stack *)
  704.     IF regs # 0D THEN            (* saved regs above result *)
  705.       IF rtyp # notyp THEN
  706.         LoadF(x)                  (* pop function result from stack *)
  707.       ELSE
  708.         (* Caution : for FCMPs/FCMPd result is in the CCR :     *)
  709.         (* -------   avoid the restoring of a single D-Register *)
  710.         (*           (eventually done by M2HM.RestoreRegs)      *)
  711.         (*           because this would destroy the CCR !       *)
  712.         Regs.All := regs; IF Regs.D # 0C THEN err(244) END;
  713.       END;
  714.       RestoreRegs(regs);          (* restore busy registers *)
  715.     END;
  716.   END FOp2;
  717.  
  718.   PROCEDURE FMonad(op : FMonadic; VAR x : Item);
  719.     (* interface to the SANE monadic operators :  *)
  720.     VAR cd : INTEGER; y : Item;
  721.   BEGIN
  722.     cd := 0; (* indicates NO FOp1-call *)
  723.     CASE op OF
  724.     | Abs :           cd := FABSs;
  725.     | NonStand :      cd := FNEGs;
  726.     | Float :         LoadX(x,long);
  727.                       x.typ := realtyp; (* essential for FOp1! *)
  728.                       FOp1(FLOATs,x);
  729.     | FloatD :        LoadX(x,long);
  730.                       x.typ := realtyp; (* essential for FOp1! *)
  731.                       FOp1(FLOATd,x);
  732.     | Long :          FOp1(FLONG,x);
  733.     | Short :         FOp1(FSHORT,x);
  734.     | Trunc :         IF x.typ # realtyp THEN err(241) END;
  735.                       FOp1(TRUNCs,x);
  736.                       LoadD(x);
  737.                       SetregMd(y, D0, inttyp);
  738.                       CheckDbltoSingle(x,y);
  739.     | TruncD :        IF x.typ # lrltyp THEN err(239) END;
  740.                       FOp1(TRUNCd,x);
  741.                       LoadD(x);
  742.     ELSE              err(200);
  743.     END (*CASE*);
  744.     IF cd # 0 THEN
  745.       IF x.typ = lrltyp THEN INC(cd,10) (* take double precision *) END;
  746.       FOp1(cd,x);
  747.     END;
  748.   END FMonad;
  749.  
  750.   PROCEDURE FDyad(op : FDyadic; VAR x, y : Item);
  751.     (* interface to the SANE dyadic operators :  *)
  752.     VAR cd : INTEGER;
  753.   BEGIN
  754.     cd := 0; (* indicates NO FOp2-call *)
  755.     CASE op OF
  756.     | plus  :         cd := FADDs;
  757.     | minus :         cd := FSUBs;
  758.     | times :         cd := FMULs;
  759.     | slash :         cd := FDIVs; IF ZeroVal(y) THEN err(205) END;
  760.     | eql .. geq :    cd := FCMPs;
  761.     ELSE              err(200);
  762.     END (*CASE*);
  763.     IF cd # 0 THEN
  764.       IF x.typ = lrltyp THEN INC(cd,10) (* take double precision *) END;
  765.       FOp2(cd,x,y);
  766.     END;
  767.     Release(y);
  768.   END FDyad;
  769.  
  770.  
  771. END M2HA. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  772.